Shareware Grab Bag/Shareware Grab Bag.iso/007/tttool30.arc/MISC.TTT

Text File | 1986-09-28 | 6KB | 204 lines

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                                                                           }
{           T E C H N O J O C K S     T U R B O    T O O L K I T            }
{                                                                           }
{                      Module   :   Misc.TTT                                }
{                                                                           }
{                      Version  :   3.0 , October 1, 1986                   }
{                                                                           }
{                      Purpose  :   Miscellaneous Utilities.                }
{                                                                           }
{                 Requirements  :   Decl.TTT                                }
{                                                                           }
{  Proc   Beep;                                                             }
{         Printscreen;                                                      }
{         Wait_for_Keypress(var Character:char);                            }
{         FlushKeyBuffer;                                                   }
{         Replicate(N:byte;character:char);                                 }
{                                                                           }
{  Func   Int_to_str(Number:integer):string20;                              }
{         Str_to_Int(Str:string80):integer;                                 }
{         Real_to_str(Number:real;Decimals:byte):string20;                  }
{         Printer_Ready:boolean;                                            }
{         Time:string20;                                                    }
{         Date:string30;                                                    }
{         MemAvail_in_Bytes:real;                                           }
{                                                                           }
{                                                Bob Ainsbury               }
{                                                Technojock                 }
{                                                Houston                    }
{                                                [phone]             }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

function time: string20;
var
  recpack:          regpack;             {assign record}
  ah,al,ch,cl,dh:   byte;
  hour,min,sec:     string[2];
  sec_int,
  min_int,
  hour_int,code:    integer;
begin
  ah := $2c;                             {initialize correct registers}
  with recpack do
  begin
    ax := ah shl 8 + al;
  end;
  intr($21,recpack);                     {call interrupt}
  with recpack do
  begin
    str(cx shr 8,hour);                  {convert to string}
    str(cx mod 256,min);                       { " }
    str(dx shr 8,sec);                         { " }
  end;
  val(hour,hour_int,code);
  val(sec,sec_int,code);
  val(min,min_int,code);
  if sec_int<10 then            {pad a leading zero if sec is < 10 }
   begin
     str(sec_int,sec);
     sec := '0'+sec;
   end;
  if min_int<10 then            {pad a leading zero if min is < 10 }
   begin
     str(min_int,min);
     min := '0'+min;
   end;
  if hour_int>12 then           { assign an a.m. or p.m. string }
   begin
    str(hour_int-12,hour);
    IF length(hour) = 1 then Hour := ' '+hour;
    time := hour+':'+min+':'+sec+' p.m.'
   end
   else
    time := hour+':'+min+':'+sec+' a.m.';
  if hour_int=12 then
   time := hour+':'+min+':'+sec+' p.m.';
end;

function Date: String30;
type
  WeekDays = array[0..6]  of string[9];
  Months   = array[1..12] of string[9];
const
    DayNames   : WeekDays  = ('Sunday','Monday','Tuesday','Wednesday',
                              'Thursday','Friday','Saturday');
    MonthNames : Months    = ('January','February','March','April','May',
                              'June','July','August','September',
                              'October','November','December');
var
 Year,
 Month,
 Day,
 DayOfWeek : integer;
 YearStr   : string4;
 DayStr    : string2;
 Recpac : regpack;
begin
 with Recpac do
 begin
  Ax := $2A00;
  Intr($21,Recpac);
  DayOfWeek := Lo(Ax);
  Year      := Cx;
  Month     := Hi(Dx);
  Day       := Lo(Dx);
 end;
 Str(Year:4,YearStr);
 Str(Day,DayStr);
 Date := DayNames[DayOfWeek] + ' ' + MonthNames[Month] +
                 ' ' + DayStr + ', ' + YearStr;
end;


Procedure PrintScreen;
var Regpack : array[1..10] of integer;
begin
intr($05,regpack);
end;

procedure Beep;
begin
sound(800);Delay(250);Nosound;
end;

procedure Wait_for_keypress(var Character:char);
begin
 Funckey := false;
 read(kbd,Character);
 if (Character = #27) and keypressed then
 begin
  read(kbd,Character);
  Funckey := true;
 end;
end;

Function Int_to_Str(Number:Integer):string20;
var Temp : string20;
begin
 Str(Number,temp);
 Int_to_Str := temp;
end;

function Real_to_str(Number:real;Decimals:byte):string20;
var Temp : string20;
begin
Str(Number:20:Decimals,Temp);
repeat
If copy(Temp,1,1) = ' ' then delete(Temp,1,1);
until copy(temp,1,1) <> ' ';
Real_to_Str := Temp;
end;

Function  Str_to_Int(Str:string80):integer;
var temp,code : integer;
begin
val(Str,temp,code);
if code = 0 then Str_to_Int := temp
else
Str_to_Int := 0;
end;

function printer_ready :boolean;
var ah : byte;
begin
ah := 2;
with recpack do
   begin
   ax := ah shl 8;
   dx := 0
   end;
intr($17,recpack);
ah := recpack.ax div 256 ;
if ah = 144 then
   printer_ready := true
else
   printer_ready := false;
end;

Procedure FlushKeyBuffer;
begin
with recpack do
begin
 Ax := ($0c shl 8) or 6;
 Dx := $00ff;
end;
Intr($21,recpack);
end;

Function MemAvail_in_Bytes:real;
var  Memleft : real;
begin
Memleft := Memavail;
If Memleft < 0 then Memleft := Memleft + 65536.;
MemAvail_in_bytes := Memleft*16;    {16 bytes in a paragraph}
end;   {proc MemAvail_in_Bytes}

Function Replicate(N : byte; Character:char):string80;
var tempstr : string80;
begin
If not (N in [1..80]) then N := 1;
fillchar(tempstr,N+1,Character);
Tempstr[0] := chr(N);
Replicate := Tempstr;
end;